home *** CD-ROM | disk | FTP | other *** search
- {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
- { }
- { TktMultiBevel v1.0 10/2/97 }
- { }
- { The TktMultiBevel is an enhanced Bevel with the possibility to choose }
- { }
- { - BorderColor, }
- { - BorderWidth, }
- { - BevelColor, }
- { - BevelWidth a.o.m. }
- { }
- { This component is freeware. Do what you want with it, but use it at your }
- { own risk. }
- { }
- { For Delphi 1 use the ressource file *.d16, for Delphi 2 and 3 *.d32. }
- { It's not necessary to rename it. }
- { }
- { }
- { It is the first release of my first component. }
- { I hope for tips. }
- { }
- { e-mail: MuK.Thaler@T-Online.de }
- { Kerstin Thaler }
- { }
- {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
-
- unit ktMBevel;
-
- interface
-
- uses
- {$IFDEF Win32} Windows, {$ELSE} WinTypes, WinProcs, {$ENDIF} Classes,
- ExtCtrls, Controls, Graphics, SysUtils;
-
- type
- TBevelStyle = (bstLowered, bstNone, bstRaised);
- TBevelShape = (bspBottomLine, bspLeftLine, bspRect, bspRightLine, bspTopLine);
- TBevelWidth = 1..MaxInt;
- TBorderWidth = 0..MaxInt;
-
- type
- TktMultiBevel = class(TGraphicControl)
- private
- FBevelInner: TBevelStyle;
- FBevelOuter: TBevelStyle;
- FBevelWidth: TBevelWidth;
- FBorderWidth: TBorderWidth;
- FColor: TColor;
- FColorFixed: Boolean;
- FColorHighlight: TColor;
- FColorShadow: TColor;
- FShape: TBevelShape;
- FTransparent: Boolean;
- procedure SetBevelInner(Value: TBevelStyle);
- procedure SetBevelOuter(Value: TBevelStyle);
- procedure SetBevelWidth(Value: TBevelWidth);
- procedure SetBorderWidth(Value: TBorderWidth);
- procedure SetColor(Value: TColor);
- procedure SetColorHighlight(Value: TColor);
- procedure SetColorFixed(Value: Boolean);
- procedure SetColorShadow(Value: TColor);
- procedure SetShape(Value: TBevelShape);
- procedure SetTransparent(Value: Boolean);
- protected
- procedure Paint; override;
- public
- constructor Create(AOwner: TComponent); override;
- destructor Destroy; override;
- published
- property Align;
- property BevelInner: TBevelStyle read FBevelInner write SetBevelInner
- default bstNone;
- property BevelOuter: TBevelStyle read FBevelOuter write SetBevelOuter
- default bstLowered;
- property BevelWidth: TBevelWidth read FBevelWidth write SetBevelWidth default 1;
- property BorderWidth: TBorderWidth read FBorderWidth write SetBorderWidth
- default 0;
- property Color: TColor read FColor write SetColor default clBtnFace;
- property ColorFixed: Boolean read FColorFixed write SetColorFixed default True;
- property ColorHighlight: TColor read FColorHighlight write SetColorHighlight
- default clBtnHighlight;
- property ColorShadow: TColor read FColorShadow write SetColorShadow
- default clBtnShadow;
- property ParentShowHint;
- property Shape: TBevelShape read FShape write SetShape default bspRect;
- property ShowHint;
- property Transparent: Boolean read FTransparent write SetTransparent
- default False;
- property Visible;
- end;
-
- procedure Register;
-
-
- implementation
-
- {$IFDEF Win32}
- {$R *.d32}
- {$ELSE}
- {$R *.d16}
- {$ENDIF}
-
-
- procedure Register;
- begin
- RegisterComponents('Samples',[TktMultiBevel]);
- end;
-
- {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
-
- { Utilities }
-
- function Min(X, Y: Integer): Integer;
- begin
- if X < Y then Result := X else Result := Y;
- end;
-
- function Max(X, Y: Integer): Integer;
- begin
- if X > Y then Result := X else Result := Y;
- end;
-
- function GetColorHighlight(BaseColor: TColor): TColor;
- begin
- Result := RGB(
- Min(GetRValue(ColorToRGB(BaseColor)) + 64, 255),
- Min(GetGValue(ColorToRGB(BaseColor)) + 64, 255),
- Min(GetBValue(ColorToRGB(BaseColor)) + 64, 255)
- );
- end;
-
- function GetColorShadow(BaseColor: TColor): TColor;
- begin
- Result := RGB(
- Max(GetRValue(ColorToRGB(BaseColor)) - 64, 0),
- Max(GetGValue(ColorToRGB(BaseColor)) - 64, 0),
- Max(GetBValue(ColorToRGB(BaseColor)) - 64, 0)
- );
- end;
-
- { TktMultiBevel }
-
- constructor TktMultiBevel.Create(AOwner: TComponent);
- begin
- inherited Create(AOwner);
- FBevelInner:= bstNone;
- FBevelOuter:= bstLowered;
- FBevelWidth:= 1;
- FBorderWidth:= 0;
- FColorShadow:= clBtnShadow;
- FColor:= clBtnFace;
- FColorFixed:= True;
- Height:= 50;
- FShape:= bspRect;
- FColorHighlight:= clBtnHighlight;
- FTransparent:= False;
- Width:= 50;
- end;
-
- destructor TktMultiBevel.Destroy;
- begin
- inherited Destroy;
- end;
-
- procedure TktMultiBevel.SetBevelInner(Value: TBevelStyle);
- begin
- if Value <> FBevelInner then
- begin
- FBevelInner := Value;
- Invalidate;
- end;
- end;
-
- procedure TktMultiBevel.SetBevelOuter(Value: TBevelStyle);
- begin
- if Value <> FBevelOuter then
- begin
- FBevelOuter := Value;
- Invalidate;
- end;
- end;
-
- procedure TktMultiBevel.SetBevelWidth(Value: TBevelWidth);
- begin
- if Value <> FBevelWidth then
- begin
- FBevelWidth := Value;
- Invalidate;
- end;
- end;
-
- procedure TktMultiBevel.SetBorderWidth(Value: TBorderWidth);
- begin
- if Value <> FBorderWidth then
- begin
- FBorderWidth := Value;
- Invalidate;
- end;
- end;
-
- procedure TktMultiBevel.SetColor(Value: TColor);
- begin
- if FColor <> Value then FColor := Value;
- if not FColorFixed then
- begin
- SetColorShadow(FColorShadow);
- SetColorHighlight(FColorHighlight);
- end
- else
- begin
- if FColor = clBtnFace then
- begin
- FColorHighlight:= clBtnHighlight;
- FColorShadow:= clBtnShadow;
- end
- else
- begin
- FColorHighlight:= GetColorHighlight(FColor);
- FColorShadow:= GetColorShadow(FColor);
- end;
- end;
- Invalidate;
- end;
-
- procedure TktMultiBevel.SetColorHighlight(Value: TColor);
- begin
- if not FColorFixed then
- begin
- if Value <> FColorHighlight then
- begin
- FColorHighlight := Value;
- Invalidate;
- end;
- end;
- end;
-
- procedure TktMultiBevel.SetColorShadow(Value: TColor);
- begin
- if not FColorFixed then
- begin
- if Value <> FColorShadow then
- begin
- FColorShadow := Value;
- Invalidate;
- end;
- end;
- end;
-
- procedure TktMultiBevel.SetColorFixed(Value: Boolean);
- begin
- if Value <> FColorFixed then
- begin
- FColorFixed := Value;
- SetColor(FColor);
- Invalidate;
- end;
- end;
-
- procedure TktMultiBevel.SetShape(Value: TBevelShape);
- begin
- if Value <> FShape then
- begin
- FShape := Value;
- Invalidate;
- end;
-
- end;
-
- procedure TktMultiBevel.SetTransparent(Value: Boolean);
- begin
- if Value <> FTransparent then
- begin
- FTransparent := Value;
- Invalidate;
- end;
- end;
-
- procedure TktMultiBevel.Paint;
- var
- RectB, RectA, RectI: TRect;
- RectBL, RectBT, RectBR, RectBB, RectIL, RectIT, RectIR, RectIB: Integer;
- P1, P2, P3, P4, P5, P6: TPoint;
-
- procedure BevelRect;
- begin
- RectA := GetClientRect;
- RectBL:= FBevelWidth;
- RectBT:= FBevelWidth;
- RectBR:= max(RectA.Right - FBevelWidth,0);
- RectBB:= max(RectA.Bottom - FBevelWidth,0);
- RectB:= rect(RectBL, RectBT, RectBR, RectBB);
- if BevelOuter = bstNone then
- begin
- RectIL:= FBorderWidth;
- RectIT:= FBorderWidth;
- RectIR:= max(RectA.Right - FBorderWidth,0);
- RectIB:= max(RectA.Bottom - FBorderWidth,0);
- end
- else
- begin
- RectIL:= RectBL + FBorderWidth;
- RectIT:= RectBT + FBorderWidth;
- RectIR:= max(RectBR - FBorderWidth,0);
- RectIB:= max(RectBB - FBorderWidth,0);
- end;
- RectI:= rect(RectIL, RectIT, RectIR, RectIB);
-
- with Canvas do
- begin
- if BevelOuter = bstNone then
- begin
- if not Transparent then
- Frame3D(Canvas, RectA, FColor, FColor, FBorderWidth);
- case BevelInner of
- bstLowered: Frame3D(Canvas, RectI, FColorShadow, FColorHighlight,
- FBevelWidth);
- bstRaised : Frame3D(Canvas, RectI, FColorHighlight, FColorShadow,
- FBevelWidth);
- end;
- end
- else
- begin
- case BevelOuter of
- bstLowered: Frame3D(Canvas, RectA, FColorShadow, FColorHighlight,
- FBevelWidth);
- bstRaised : Frame3D(Canvas, RectA, FColorHighlight, FColorShadow,
- FBevelWidth);
- end;
- if not Transparent then
- Frame3D(Canvas, RectB, FColor, FColor, FBorderWidth);
- case BevelInner of
- bstLowered: Frame3D(Canvas, RectI, FColorShadow, FColorHighlight,
- FBevelWidth);
- bstRaised : Frame3D(Canvas, RectI, FColorHighlight, FColorShadow,
- FBevelWidth);
- end;
- end;
- end;
- end;
-
- procedure FillBorder;
- var b: Integer;
- begin
- if not Transparent then
- begin
- if (FBorderWidth mod 2) = 1 then b:= (FBorderWidth + 1) div 2
- else b:= FBorderWidth div 2;
- case Shape of
- bspBottomLine: begin
- P5.x:= BevelWidth;
- P6.x:= RectA.Right - FBevelWidth;
- P5.y:= RectA.Bottom - FBevelWidth - b;
- P6.y:= P5.y;
- end;
- bspTopLine : begin
- P5.x:= BevelWidth;
- P6.x:= RectA.Right - FBevelWidth;
- P5.y:= FBevelWidth + b;
- P6.y:= P5.y;
- end;
- bspLeftLine : begin
- P5.x:= FBevelWidth + b;
- P6.x:= P5.x;
- P5.y:= BevelWidth;
- P6.y:= RectA.Bottom - FBevelWidth;
- end;
- bspRightLine : begin
- P5.x:= RectA.Right - FBevelWidth - b;
- P6.x:= P5.x;
- P5.y:= BevelWidth;
- P6.y:= RectA.Bottom - FBevelWidth;
- end;
- end;
- with Canvas do
- begin
- Pen.Color:= FColor;
- Pen.Width:= BorderWidth;
- MoveTo(P5.x,P5.y);
- LineTo(P6.x,P6.y);
- end;
- end;
- end;
-
- procedure PaintRightOrBottom;
- var i: Integer;
- begin
- with Canvas do
- begin
- Canvas.Pen.Width:= 1;
- for i:= 1 to FBevelWidth do
- begin
- case FBevelOuter of
- bstRaised : Pen.Color:= FColorHighlight;
- bstLowered: Pen.Color:= FColorShadow;
- end;
- PolyLine([P1,P2,P3]);
- case FBevelOuter of
- bstRaised : Pen.Color:= FColorShadow;
- bstLowered: Pen.Color:= FColorHighlight;
- end;
- dec(P3.y);
- PolyLine([P1,P4,P3]);
- inc(P3.y);
- inc(P1.x);
- dec(P1.y);
- inc(P2.x);
- inc(P2.y);
- dec(P3.x);
- inc(P3.y);
- dec(P4.x);
- dec(P4.y);
- end;
- dec(P3.y);
- PolyLine([P1,P4,P3]);
- end;
- end;
-
- procedure BottomLine;
- begin
- if (FBevelOuter <> bstNone) or not Transparent then
- begin
- RectA := GetClientRect;
- P1.x:= 0;
- P1.y:= RectA.Bottom;
- P2.x:= 0;
- P2.y:= RectA.Bottom - 2*FBevelWidth - FBorderWidth;
- P3.x:= RectA.Right;
- P3.y:= P2.y;
- P4.x:= P3.x;
- P4.y:= P1.y;
- FillBorder;
- if FBevelOuter <> bstNone then PaintRightOrBottom;
- end;
- end;
-
- procedure RightLine;
- begin
- if (FBevelOuter <> bstNone) or not Transparent then
- begin
- RectA := GetClientRect;
- P1.x:= RectA.Right - 2*FBevelWidth - FBorderWidth;
- P1.y:= RectA.Bottom;
- P2.x:= P1.x;
- P2.y:= 0;
- P3.x:= RectA.Right;
- P3.y:= 0;
- P4.x:= P3.x;
- P4.y:= P1.y;
- FillBorder;
- if FBevelOuter <> bstNone then PaintRightOrBottom;
- end;
- end;
-
- procedure PaintLeftOrTop;
- begin
- RectBL:= 0;
- RectBT:= 0;
- RectB:= rect(RectBL, RectBT, RectBR, RectBB);
- with Canvas do
- begin
- FillBorder;
- case BevelOuter of
- bstLowered: Frame3D(Canvas, RectB, FColorShadow, FColorHighlight, FBevelWidth);
- bstRaised : Frame3D(Canvas, RectB, FColorHighlight, FColorShadow, FBevelWidth);
- end;
- end;
- end;
-
- procedure LeftLine;
- begin
- RectA := GetClientRect;
- RectBR:= FBorderWidth + 2*FBevelWidth;
- RectBB:= RectA.Bottom;
- PaintLeftOrTop;
- end;
-
- procedure TopLine;
- begin
- RectA := GetClientRect;
- RectBR:= RectA.Right;
- RectBB:= FBorderWidth + 2*FBevelWidth;
- PaintLeftOrTop;
- end;
-
-
- begin
- case FShape of
- bspBottomLine : BottomLine;
- bspLeftLine : LeftLine;
- bspRect : BevelRect;
- bspRightLine : RightLine;
- bspTopLine : TopLine;
- end;
- end;
-
- end.
-
-
-
-